home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / link / linker.t < prev    next >
Encoding:
Text File  |  1988-05-02  |  22.6 KB  |  549 lines
  1. (herald linker
  2.   (env t (link defs))); (osys load_comex)))
  3.  
  4. ;;; This is all straightforward except for the 'linker magic'  i.e. the
  5. ;;; bootstrap symbols.  These are variables which are needed by the image
  6. ;;; being built (referenced in modules being linked) but which cannot be
  7. ;;; defined in any single module.  After all other references have been resolved
  8. ;;; the linker pretends that these variables have been defined by filling
  9. ;;; the references with its own data structures.
  10.  
  11. (import t-implementation-env make-table-with-size iob? vm-write-char
  12.     read-comex-from-file symbol-length symbol-hash %%symbol-text-offset
  13.     double-float?)
  14.     
  15.  
  16.  
  17. (define-local-syntax (dotimes spec . body)
  18.   (let ((index (car spec))
  19.         (limit (cadr spec)))
  20.     `(do ((,index 0 (fx+ ,index 1)))
  21.          ((fx= ,index ,limit))
  22.        ,@body)))
  23.  
  24. (lset *null-descriptor* nil)
  25. (lset *symbols* nil)          
  26. (lset *boot-env* nil)
  27. (lset *lstate* nil)
  28. (lset *var-table* nil)
  29. (lset *reloc-table* nil)
  30. (lset *linker-noise-file* nil)
  31.  
  32. (define (really-link modules obj-type out-spec out-type)                                             
  33.   (linker-message "~&Linking ~a ... ~%" out-spec)
  34.   (bind ((*null-descriptor* nil)
  35.          (*symbols* '())
  36.          (*boot-env* '())
  37.          (*lstate* (create-lstate))
  38.          (*var-table* (make-table-with-size 2000 'linker-var-table))
  39.          (*reloc-table* (make-table-with-size 16000 'linker-reloc-table)))
  40.     (let ((comex-list 
  41.            (map (lambda (file) 
  42.                   (read-comex-from-file (filename-with-type (->filename file) 
  43.                                                             obj-type)))
  44.                 modules)))
  45.       (linker-message "~&resolving modules~%")
  46.       (let* ((units (linker-resolve comex-list))
  47.              (unit-vec (list->vector units))
  48.              (filename (->filename out-spec)))
  49.         (define-null-descriptor (lstate-impure *lstate*))
  50.         (relocate-units units unit-vec)
  51.         (patch-in-definitions unit-vec 
  52.                               (map cons (map comex-code comex-list) units))
  53.         (with-open-ports 
  54.          ((image (open (filename-with-type filename out-type) '(out)))
  55.           (map  (open (filename-with-type filename 'map) '(out))))
  56.          (linker-message "~&writing object file~%")
  57.          (set (lstate-pure-size *lstate*) 
  58.               (area-frontier (lstate-pure *lstate*)))
  59.          (table-walk *var-table* 
  60.                      (lambda (name node)
  61.                        (cond ((not (var-node-defined node))
  62.                               (warning "undefined global ~S" name))
  63.                              (else
  64.                               (write-map-entry map name (var-node-value node))))))
  65.          (write-link-file image)
  66.          *lstate*)))))
  67.  
  68. (define (linker-resolve comi)
  69.   (do ((comi comi (cdr comi))
  70.        (units '() (cons (instantiate-comex (car comi)) units)))
  71.       ((null? comi)
  72.        (reverse! units))))
  73.  
  74. (define (instantiate-comex comex)
  75.   (let* ((objects (comex-objects comex))
  76.          (opcodes (comex-opcodes comex))
  77.          (code (comex-code comex))
  78.          (unit-len (vector-length objects))
  79.          (unit (make-vector (fx+ unit-len 1))))
  80.     (do ((i 1 (fx+ i 1)))
  81.         ((fx> i unit-len)
  82.          unit)
  83.       (let ((ob (vref objects (fx- i 1))))
  84.         (xselect (bref opcodes (fx- i 1))
  85.           ((op/literal)
  86.            (set (vref unit i) ob))
  87.           ((op/foreign)
  88.            (set (vref unit i)
  89.                 (cond ((mem (lambda (x y) (eq? x (foreign-object-name y)))
  90.                             ob
  91.                             (lstate-foreign *lstate*))
  92.                        => car)
  93.                       (else
  94.                        (let ((new (make-foreign-object)))
  95.                          (set (foreign-object-name new) ob)
  96.                          (push (lstate-foreign *lstate*) new)
  97.                          new)))))
  98.           ((op/closure)
  99.            (let ((new (make-templat)))
  100.              (set (templat-code-vec new) code)
  101.              (set (templat-offset new) ob)  
  102.              (set (vref unit i) new)))
  103.           ((op/template1)
  104.            (let ((new (make-cit)))
  105.              (set-template-store-slots new code ob i)
  106.              (set (vref unit i) new)))
  107.           ((op/template2) (set (vref unit i) no-op))
  108.           ((op/template3) (set (vref unit i) no-op))
  109.           ((op/vcell-stored-definition)
  110.            (let ((v (get-vcell (car ob) 'define unit i)))
  111.              (set (var-node-value (vcell-struct-var v))
  112.           (create-unit-loc unit (cdr ob)))
  113.              (set (vref unit i) v)))
  114.           ((op/vcell-defined)                
  115.            (set (vref unit i) (get-vcell ob 'define unit i)))
  116.           ((op/vcell-lset)           
  117.            (set (vref unit i) (get-vcell ob 'lset unit i)))
  118.           ((op/vcell)
  119.            (set (vref unit i) (get-vcell ob nil unit i)))
  120.           ((op/variable-value)
  121.            (set (vref unit i) (add-to-var-refs ob unit i))))))))
  122.  
  123. (define (cons-a-var-node name)
  124.   (let ((var (make-var-node))
  125.     (vcell (make-vcell-struct)))
  126.     (set (var-node-name var) name)
  127.     (set-table-entry *var-table* name var)
  128.     (set (vcell-struct-var vcell) var)
  129.     (set (var-node-vcell var) vcell)
  130.     (push *boot-env* (cons name vcell))
  131.     var))
  132.                      
  133.     
  134. (define (add-to-var-refs name unit index)
  135.   (let ((node (cond ((table-entry *var-table* name))
  136.                     (else (cons-a-var-node name)))))
  137.     (push (var-node-refs node) (cons unit (fx- index 1))) ; unit is closure
  138.     node))                                         
  139.  
  140. (define (get-vcell name definer unit index)
  141.   (let ((node (cond ((table-entry *var-table* name))
  142.                     (else (cons-a-var-node name)))))
  143.     (cond (definer                                        ; not vector
  144.            (if (var-node-defined node) (warning "~S multiply defined" name))
  145.            (set (var-node-defined node) definer)))
  146.     (push (var-node-vcell-refs node) (cons unit (fx- index 1))) ; unit is closure
  147.     (var-node-vcell node)))
  148.  
  149.  
  150. (define-constant BOOTSTRAP-SYMBOLS 
  151.   '(*boot-env* 
  152.     *the-initial-symbols* 
  153.     *the-slink*
  154.     *the-initial-modules*
  155.     *code-unit-map*))
  156.  
  157. ;;; these better not get called
  158.  
  159. (define (patch-in-definitions unit-vec code-unit-map) 
  160.   (patch '*the-initial-modules* unit-vec)
  161.   (patch '*code-unit-map* code-unit-map)
  162.   (patch '*the-slink* nil)
  163.   (patch '*the-initial-symbols* (list->vector *symbols*))
  164.   (patch '*boot-env* *boot-env*))
  165.  
  166. (define (patch name definition)
  167.   (cond ((table-entry *var-table* name)
  168.          => (lambda (node)
  169.               (and (var-node-defined node)
  170.            (warning "~S multiply defined" name))
  171.               (set (var-node-defined node) 'define)
  172.               (set (var-node-value node) definition)
  173.           (let ((desc (table-entry *reloc-table* (var-node-vcell node))))
  174.         (generate-slot-relocation definition (fx+ (heap-offset desc) 4)))
  175.           (let* ((vec (var-node-refs node))
  176.                      (size (vector-length vec)))
  177.                 (do ((i 0 (fx+ i 2)))
  178.                     ((fx>= i size))
  179.                   (generate-slot-relocation
  180.                     definition
  181.                     (fx+ (heap-offset (table-entry *reloc-table* (vref vec i))) 
  182.                          (fx* CELL (fx+ (vref vec (fx+ i 1)) 1))))))))))
  183.                     
  184.  
  185.         
  186.  
  187.  
  188. ;;; Virtual GC
  189.           
  190. (define (vgc root)
  191.   (cond ((null? root) *null-descriptor*)
  192.         ((table-entry *reloc-table* root))
  193.         (else
  194.          (allocate root))))
  195.  
  196. ;;; ALLOCATE reserves space on an appropriate heap for obj, and
  197. ;;; associates the resulting descriptor object with obj in the
  198. ;;; relocation table.  It checks all of obj's children to ensure that
  199. ;;; they have descriptors in the relocation table (and are thus
  200. ;;; allocated), and generates relocation requests for all obj's slots
  201. ;;; that contain stored descriptors.
  202.  
  203. (define (allocate obj)
  204.   ((xcond ((pair? obj) vgc-copy-pair)
  205.           ((vector? obj) vgc-copy-vector)
  206.           ((templat? obj) vgc-copy-template)
  207.           ((symbol? obj) vgc-copy-symbol)
  208.           ((bytev? obj)  vgc-copy-bytev)
  209.           ((string? obj) vgc-copy-string)
  210.           ((text? obj) vgc-copy-text)        
  211.           ((vcell-struct? obj) vgc-copy-vcell)       
  212.           ((address? obj) vgc-copy-address)
  213.           ((foreign-object? obj) vgc-copy-foreign)
  214.           ((double-float? obj) vgc-copy-double-float))
  215.    obj))
  216.  
  217. (define (define-null-descriptor heap)
  218.   (modify (area-frontier heap)
  219.           (lambda (x) (fx+ x %%slink-size)))
  220.   (set *null-descriptor*
  221.        (object nil
  222.          ((heap-stored self) heap)
  223.          ((heap-offset self) tag/pair)
  224.          ((write-descriptor self stream)
  225.           (write-data stream tag/pair))
  226.          ((write-store self stream)
  227.           (let ((pi (fx+ slink/initial-pure-memory-begin 3)))
  228.             (do ((i 0 (fx+ i 4)))
  229.                 ((fx= i pi)
  230.                  (write-int stream 0)
  231.                  (write-int stream (area-frontier (lstate-pure *lstate*)))
  232.                  (write-data stream 0)
  233.                  (write-data stream (area-frontier (lstate-impure *lstate*)))
  234.                  (do ((i (fx+ i 16) (fx+ i 4)))
  235.                      ((fx= i %%slink-size))
  236.                    (write-int stream 0)))
  237.               (write-int stream 0))))))
  238.   (push (area-objects heap) *null-descriptor*)
  239.   (set-table-entry *reloc-table* nil *null-descriptor*)
  240.   (text-relocation (fx+ slink/initial-pure-memory-begin 3))
  241.   (text-relocation (fx+ slink/initial-pure-memory-end 3))
  242.   (data-relocation (fx+ slink/initial-impure-memory-begin 3))
  243.   (data-relocation (fx+ slink/initial-impure-memory-end 3)))
  244.  
  245.                                           
  246. (define (vgc-copy-pair pair)
  247.   (let* ((heap (lstate-impure *lstate*))
  248.          (addr (area-frontier heap))
  249.          (desc (object nil
  250.                  ((heap-stored self) (lstate-impure *lstate*))
  251.                  ((heap-offset self) addr)
  252.                  ((write-descriptor self stream)       
  253.                   (write-data stream (fx+ addr tag/pair)))
  254.                  ((write-store self stream)
  255.                   (write-slot (cdr pair) stream)
  256.                   (write-slot (car pair) stream)))))
  257.       (set (area-frontier heap) (fx+ addr (fx* CELL 2)))
  258.       (push (area-objects heap) desc)
  259.       (set-table-entry *reloc-table* pair desc)
  260.       ;;Trace from the cdr first to linearise lists
  261.       (generate-slot-relocation (cdr pair) addr)
  262.       (generate-slot-relocation (car pair) (fx+ CELL addr))
  263.       desc))
  264.  
  265. (define (vgc-copy-vector vec)
  266.   (let* ((heap (lstate-impure *lstate*))
  267.          (addr (area-frontier heap))
  268.          (nelts (vector-length vec))
  269.          (desc (object nil
  270.                  ((heap-stored self) (lstate-impure *lstate*))
  271.                  ((heap-offset self) addr)
  272.                  ((write-descriptor self stream)
  273.                   (write-data stream (fx+ addr tag/extend)))
  274.                  ((write-store self stream)
  275.                   ;;The header                                
  276.                   (let ((nelts (vector-length vec)))
  277.                     (write-int stream (fx+ (fixnum-ashl nelts 8)
  278.                                            (fx+ header/general-vector 128)))
  279.                     (dotimes (i nelts)
  280.                       (write-slot (vref vec i) stream)))))))
  281.       (set (area-frontier heap) (fx+ addr (fx+ CELL (fx* CELL nelts))))
  282.       (push (area-objects heap) desc)
  283.       (set-table-entry *reloc-table* vec desc)
  284.       (do ((i 0 (fx+ i 1))
  285.            (a (fx+ addr CELL) (fx+ a CELL)))
  286.           ((fx= i nelts))
  287.         (generate-slot-relocation (vref vec i) a))
  288.       desc))
  289.                                               
  290. (define (relocate-units the-units unit-vec)
  291.   (let* ((heap (lstate-impure *lstate*))
  292.          (begin (area-frontier heap))) 
  293.     (do ((units the-units (cdr units))
  294.          (addr begin (fx+ addr (fx* CELL (vector-length (car units))))))
  295.         ((null? units)
  296.          (set (area-frontier heap) addr)
  297.          (vgc-copy-vector unit-vec)
  298.          (walk (lambda (unit)
  299.                  (relocate-unit-1 unit))
  300.                the-units))
  301.       (let ((desc (object nil
  302.                     ((heap-stored self) (lstate-impure *lstate*))
  303.                     ((heap-offset self) addr)   
  304.                     ((write-descriptor self stream)
  305.                      (write-data stream (fx+ addr tag/extend)))
  306.                     ((write-store self stream)
  307.                      (let ((slots (fx- (vector-length (car units)) 1)))
  308.                        (write-int stream (fx+ (fixnum-ashl slots 8) 
  309.                                               header/unit))
  310.                        (do ((i 1 (fx+ i 1)))
  311.                            ((fx> i slots) t)
  312.                          (let ((ob (vref (car units) i)))
  313.                            ;;We have to special case closure-internal templates
  314.                            (cond ((cit? ob)
  315.                                   (write-template stream ob))
  316.                                  ((var-node? ob)
  317.                                   (write-var-ref stream ob))
  318.                                  ((no-op? ob))
  319.                                  (else
  320.                                   (write-slot ob stream))))))))))
  321.         (push (area-objects heap) desc)
  322.         (set-table-entry *reloc-table* (car units) desc)))))
  323.                                                                           
  324. (define (relocate-unit-1 unit)
  325.   (let* ((desc (table-entry *reloc-table* unit))
  326.          (nslots (vector-length unit)))
  327.     (do ((i 1 (fx+ i 1))
  328.          (a (fx+ (heap-offset desc) CELL) (fx+ a CELL)))
  329.         ((fx= i nslots))
  330.       (let ((ob (vref unit i)))
  331.         ;;We have to special case closure-internal templates
  332.         (cond ((cit? ob)
  333.                (generate-slot-relocation (cit-code-vec ob) 
  334.                                          (fx+ a (fx* CELL 2))
  335.                                          ))
  336.               ((no-op? ob))              
  337.               ((var-node? ob)
  338.                (relocate-unit-variable ob a nil))
  339.               (else
  340.                (generate-slot-relocation ob a)))))))
  341.  
  342. (define (vgc-copy-vcell vcell)
  343.   (let* ((heap (lstate-impure *lstate*))
  344.          (addr (area-frontier heap))
  345.          (var (vcell-struct-var vcell))
  346.          (desc (object nil
  347.                  ((heap-stored self) (lstate-impure *lstate*))
  348.                  ((heap-offset self) addr)   
  349.                  ((write-descriptor self stream)
  350.                   (write-data stream (fx+ addr tag/extend)))
  351.                  ((write-store self stream)
  352.           (write-vcell-header var stream)
  353.                   (write-var-ref stream var)
  354.                   (write-data stream (fx+ addr 22)) 
  355.                   (write-slot (var-node-name var) stream)
  356.           (write-data stream (fx+ addr 30))
  357.                   (write-int stream header/weak-alist)
  358.                   (write-slot (var-node-refs var) stream)
  359.                   (write-int stream header/weak-alist)
  360.                   (write-slot (var-node-vcell-refs var) stream)))))
  361.     (set (area-frontier heap) (fx+ addr (fx* CELL 9)))  ; 5 for vcell
  362.     (set-table-entry *reloc-table* vcell desc)          ; 4 for weak-alists
  363.     (push (area-objects heap) desc) 
  364.     (relocate-unit-variable var (fx+ addr CELL) t)
  365.     (set (var-node-refs var) (a-list->vector (var-node-refs var)))
  366.     (set (var-node-vcell-refs var) (a-list->vector (var-node-vcell-refs var)))
  367.     (generate-slot-relocation (var-node-refs var) (fx+ addr (fx* CELL 6)))
  368.     (generate-slot-relocation (var-node-vcell-refs var) (fx+ addr (fx* CELL 8)))
  369.     (generate-slot-relocation (var-node-name var) (fx+ addr (fx* CELL 3)))
  370.     (data-relocation (fx+ addr (fx* CELL 2)))
  371.     (data-relocation (fx+ addr (fx* CELL 4)))
  372.     desc))
  373.                                                                   
  374. (define (a-list->vector a)
  375.   (let ((vec (make-vector (fx* (length a) 2))))
  376.     (do ((i 0 (fx+ i 2))
  377.          (a a (cdr a)))
  378.         ((null? a) vec)
  379.       (set (vref vec i) (caar a))
  380.       (set (vref vec (fx+ i 1)) (cdar a)))))
  381.  
  382. (define (vgc-copy-template tmplt)
  383.   (let* ((cv (vgc (templat-code-vec tmplt)))
  384.          (desc (object nil
  385.                  ((heap-stored self) (lstate-pure *lstate*))
  386.                  ((write-descriptor self stream)
  387.                   (write-int stream (fx+ (templat-offset tmplt)
  388.                                          (fx+ (heap-offset cv) CELL)))))))
  389.     (set-table-entry *reloc-table* tmplt desc)
  390.     desc))
  391.  
  392. (define (vgc-copy-symbol sym)
  393.   (push *symbols* sym)
  394.   (let* ((heap (lstate-pure *lstate*))
  395.          (addr (area-frontier heap))
  396.          (end-addr (fx+ CELL (fx+ addr (symbol-length sym))))
  397.          (desc (object nil
  398.                  ((heap-stored self) (lstate-pure *lstate*))
  399.                  ((heap-offset self) addr)
  400.                  ((write-descriptor self stream)
  401.                   (write-int stream (fx+ (heap-offset self) tag/extend)))
  402.                  ((write-store self stream)
  403.                   (let ((len (symbol-length sym)))
  404.                     (write-int stream (fx+ (fixnum-ashl len 8)
  405.                                            (fx+ header/symbol 128)))
  406.                     (write-fixnum stream (symbol-hash sym))
  407.                     (write-block stream sym %%symbol-text-offset len)
  408.                     (dotimes (i (fx- (align len 2) len))
  409.                       (write-byte stream 0)))))))
  410.     (set (area-frontier heap) (align end-addr 2))
  411.     (push (area-objects heap) desc)
  412.     (set-table-entry *reloc-table* sym desc)
  413.     desc))
  414.                                                                                   
  415. (define (vgc-copy-bytev vec)
  416.   (vgc-copy-bytes vec (bytev-length vec) header/bytev))
  417.  
  418. (define (vgc-copy-text text) 
  419.   (vgc-copy-bytes text (text-length text) header/text))
  420.  
  421. (define (vgc-copy-bytes bytes vlen header)
  422.   (let* ((heap (lstate-pure *lstate*))
  423.          (addr (area-frontier heap))
  424.          (end-addr (fx+ CELL (fx+ addr vlen)))
  425.          (desc (object nil
  426.                  ((heap-stored self) (lstate-pure *lstate*))
  427.                  ((heap-offset self) addr)    
  428.                  ((write-descriptor self stream)
  429.                   (write-int stream (fx+ addr tag/extend)))
  430.                  ((write-store self stream)           
  431.                   (let ((vlen (bytev-length bytes)))
  432.                     (write-int stream (fx+ (fixnum-ashl vlen 8)
  433.                                            (fx+ header 128)))
  434.                     (write-block stream bytes 0 vlen)
  435.                     ;;Pad to the next cell boundary.
  436.                     (dotimes (i (fx- (align vlen 2) vlen))
  437.                       (write-byte stream 0)))))))
  438.     (set (area-frontier heap) (align end-addr 2))
  439.     (push (area-objects heap) desc)
  440.     (set-table-entry *reloc-table* bytes desc)
  441.     desc))
  442.  
  443. (define (vgc-copy-string str)
  444.   (let* ((heap (lstate-impure *lstate*))
  445.          (addr (area-frontier heap))
  446.          (text (string-text str)) 
  447.          (desc (object nil
  448.                  ((heap-stored self) (lstate-impure *lstate*))
  449.                  ((heap-offset self) addr)
  450.                  ((write-descriptor self stream)
  451.                   (write-data stream (fx+ addr tag/extend)))
  452.                  ((write-store self stream)
  453.                   (write-int stream (fx+ (fixnum-ashl (text-length text) 8)
  454.                                          header/slice))
  455.                   (write-slot text stream)
  456.                   (write-int stream 0)))))       ;; offset
  457.     (set (area-frontier heap) (fx+ addr (fx* CELL 3)))
  458.     (set-table-entry *reloc-table* str desc)
  459.     (push (area-objects heap) desc)
  460.     (generate-slot-relocation text (fx+ addr CELL))
  461.     desc))                    
  462.  
  463. (define (write-var-ref stream var)
  464.   (cond ((neq? (var-node-value var) NONVALUE)
  465.          (let ((value (var-node-value var)))
  466.             (if (unit-loc? value)
  467.                 (write-unit-loc stream value)
  468.                 (write-slot value stream))))
  469.         (else
  470.          (write-int stream header/nonvalue))))
  471.                                                      
  472. ;;; Flonum dismemberment.
  473.  
  474. ;;; Returns sign, and normalized mantissa and exponent  
  475. ;;; PRECISION is number of bits desired in the mantissa 
  476. ;;; EXCESS is the exponent excess
  477. ;;; HIDDEN-BIT-IS-1.? is true if the hidden bit preceeds the
  478. ;;;  binary point (it does in Apollo IEEE, does not on the VAX).
  479.  
  480. (define (normalized-float-parts flonum precision excess hidden-bit-is-1.?)
  481.     (cond ((fl= flonum 0.0)
  482.            (return 0 (%ash 1 (fx+ precision 1)) 0))
  483.           (else
  484.            (receive (#f m e) (integer-decode-float flonum)
  485.               (let* ((have (integer-length m))
  486.                      (need (fx- precision have))
  487.                      (normalized-m (%ash m need))
  488.                      (normalized-e (- (+ e 
  489.                                          precision 
  490.                                          excess
  491.                                          (if hidden-bit-is-1.? -1 0))
  492.                                        need)))
  493.                  (return (if (fl< flonum 0.0) 1 0) normalized-m normalized-e))))))
  494.  
  495. (define (vgc-copy-double-float float)
  496.   (let* ((heap (lstate-pure *lstate*))
  497.          (addr (area-frontier heap))
  498.          (desc (object nil
  499.                  ((heap-stored self) (lstate-pure *lstate*))
  500.                  ((heap-offset self) addr)
  501.                  ((write-descriptor self stream)
  502.                   (write-int stream (fx+ addr tag/extend)))
  503.                  ((write-store self stream)
  504.                   (write-double-float stream float)))))
  505.     (set (area-frontier heap) (fx+ addr (fx* CELL 3)))
  506.     (set-table-entry *reloc-table* float desc)
  507.     (push (area-objects heap) desc)
  508.     desc))                    
  509.                                                           
  510. ;;; Floating point bit fields.
  511.  
  512. ;;; <n,s> means bit field of length s beginning at bit n of the first
  513. ;;; WORD (not longword)
  514. ;;;                    sign      exponent   MSB       fraction
  515. ;;; Apollo IEEE flonum <15,1>    <4,11>     hidden    <0,4>+next 3 words
  516. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  517. ;;; Apollo IEEE flonum - binary point follows  hidden MSB, 53 bits of
  518. ;;;     precision, if hidden bit is included
  519. ;;; VAX11 flonum (D)   - binary point precedes hidden MSB, 56 bits of
  520. ;;;     precision, if hidden bit is included 
  521.  
  522.  
  523. (define (write-block port obj start len)
  524.   (let ((writec (if (iob? port) vm-write-char write-char)))
  525.     (do ((i start (fx+ i 1)))
  526.         ((fx>= i len))
  527.       (writec port (text-elt obj i)))))
  528.  
  529.  
  530. (define (write-unit-loc stream u)
  531.   (write-data stream (fx+ (heap-offset (table-entry *reloc-table* (unit-loc-unit u)))
  532.                          (fx+ tag/extend
  533.                               (unit-loc-offset u)))))
  534.  
  535. (define (unit-var-value value)
  536.   (if (unit-loc? value)
  537.       (fx+ (heap-offset (table-entry *reloc-table* (unit-loc-unit value)))
  538.            (fx+ (unit-loc-offset value) tag/extend))
  539.       (heap-offset (table-entry *reloc-table* value))))
  540.  
  541. (define-integrable (align n m)
  542.   (let ((2^m-1 (fx- (fixnum-ashl 1 m) 1)))
  543.     (fixnum-logand (fx+ n 2^m-1) (fixnum-lognot 2^m-1))))
  544.  
  545. (define-operation (heap-stored obj))
  546. (define-operation (heap-offset obj))           
  547. (define-operation (write-descriptor obj stream))
  548. (define-operation (write-store obj stream))
  549.